25  Многоклассовая классификация

Многоклассовая классификация может использоваться для определения автора, жанра, тематики или эмоциональной тональности текста.

library(tidyverse)
library(textrecipes)
library(tidymodels)
library(tidytext)

25.1 Данные

https://www.kaggle.com/datasets/mikhailklemin/kinopoisks-movies-reviews

path_neg <- list.files("../files/kinopoisk/neg", full.names = TRUE)
path_pos <- list.files("../files/kinopoisk/pos", full.names = TRUE)
path_neu <- list.files("../files/kinopoisk/neu", full.names = TRUE)

# для ускорения вычислений на занятии
path_sel <- c(path_neg[1:1000], path_pos[1:1000], path_neu[1:1000])
read_review <- function(path) {
  tibble(review = read_lines(path) |>
           str_c(collapse = " "),
         sentiment = str_extract(path, "pos|neg|neu"))
}

reviews <- map_df(path_sel, read_review)
reviews

25.2 Разведывательный анализ

В нашем датасете есть несколько очень коротких рецензий. Негативные рецензии в целом длиннее позитивных и нейтральных.

reviews |> 
  mutate(n_words = str_count(review, " ") + 1) |> 
  ggplot(aes(n_words, fill = sentiment)) +
  geom_histogram(bins = 100) +
  xlab(NULL) +
  ylab(NULL) +
  scale_fill_viridis_d() + 
  theme_light()

Посмотрим на число уникальных токенов в каждой из категорий.

reviews_tokens <- reviews |> 
  mutate(id = row_number(), .before = sentiment) |> 
  unnest_tokens(token, review) 

reviews_tokens |> 
  group_by(sentiment) |> 
  summarise(n = n_distinct(token))

Большая часть слов встречается очень редко.

reviews_tokens |> 
  count(sentiment, token) |> 
  ggplot(aes(n, fill = sentiment)) +
  geom_histogram(show.legend = FALSE, bins = 1000) +
  coord_cartesian(xlim = c(NA, 2500), ylim = c(NA, 2500)) +
  theme_light() +
  scale_fill_viridis_d()

Здесь можно добавить пример из https://juliasilge.com/blog/nber-papers/.

25.3 Обучающая и тестовая выборки

set.seed(09032025)
data_split <- reviews |> 
  mutate(sentiment = as.factor(sentiment)) |> 
  initial_split( strata = sentiment)
data_train <- training(data_split) 
data_test <- testing(data_split)
# folds
set.seed(09032025)
folds <- vfold_cv(data_train, strata = sentiment, v = 5)
folds

25.4 Препроцессинг: tf-idf

library(stopwords)
stopwords_ru <- c(
  stopwords("ru", source = "snowball"),
  stopwords("ru", source = "marimo"),
  stopwords("ru", source = "nltk"))

# уберем повторы и упорядочим по алфавиту
stopwords_ru <- sort(unique(stopwords_ru))
length(stopwords_ru)
[1] 380

Подробнее о рецепте см. https://smltar.com/mlregression#firstregression

tfidf_rec <- recipe(sentiment ~ review, data = data_train) |>
  step_mutate(review = stringr::str_remove_all(review, "\\d+")) |> 
  step_mutate(review = stringr::str_remove_all(review, "[A-Za-z]")) |> 
  step_tokenize(review) |>
  step_stopwords(review, custom_stopword_source = stopwords_ru) |>
  step_stem(review, options = list(language = "russian")) |>
  step_tokenfilter(all_predictors(), 
                   max_tokens = 1000, 
                   min_times = 2) |> 
  step_tfidf(review) |> 
  step_zv(all_predictors()) |> 
  step_normalize(all_predictors())

tfidf_rec
── Recipe ──────────────────────────────────────────────────────────────────────
── Inputs 
Number of variables by role
outcome:   1
predictor: 1
── Operations 
• Variable mutation for: stringr::str_remove_all(review, "\\d+")
• Variable mutation for: stringr::str_remove_all(review, "[A-Za-z]")
• Tokenization for: review
• Stop word removal for: review
• Stemming for: review
• Text filtering for: all_predictors()
• Term frequency-inverse document frequency with: review
• Zero variance filter on: all_predictors()
• Centering and scaling for: all_predictors()

25.5 Препроцессинг: PCA

pca_rec <- recipe(sentiment ~ review, data = data_train) |>
  step_mutate(review = stringr::str_remove_all(review, "\\d+")) |> 
  step_mutate(review = stringr::str_remove_all(review, "[A-Za-z]")) |> 
  step_tokenize(review) |>
  step_stopwords(review, custom_stopword_source = stopwords_ru) |>
  step_stem(review, options = list(language = "russian")) |>
  step_tokenfilter(all_predictors(), 
                   max_tokens = 1000, 
                   min_times = 2) |> 
  step_tfidf(review) |> 
  step_zv(all_predictors()) |> 
  step_normalize(all_predictors()) |> 
  step_pca(all_predictors(), num_comp = 100)

pca_rec
── Recipe ──────────────────────────────────────────────────────────────────────
── Inputs 
Number of variables by role
outcome:   1
predictor: 1
── Operations 
• Variable mutation for: stringr::str_remove_all(review, "\\d+")
• Variable mutation for: stringr::str_remove_all(review, "[A-Za-z]")
• Tokenization for: review
• Stop word removal for: review
• Stemming for: review
• Text filtering for: all_predictors()
• Term frequency-inverse document frequency with: review
• Zero variance filter on: all_predictors()
• Centering and scaling for: all_predictors()
• PCA extraction with: all_predictors()

На очень большом числа признаков step_pca() может сильно замедлять вычисления, в этом случае можно попробовать step_pca_truncated() из пакета {embed}.

Также стоит помнить, что PCA выполняет линейное снижение размерности, что не всегда подходит. Для нелинейного подхода воспользуйтесь функцией step_umap() из того же пакета.

25.6 Результат препроцессинга

prep_train_tfidf <- tfidf_rec |>
  prep(data_train) 

tidy(prep_train_tfidf)
bake_train_tfidf <- prep_train_tfidf |> 
  bake(new_data = NULL)

bake_train_tfidf
prep_train_pca <- pca_rec |>
  prep(data_train) 

tidy(prep_train_pca)

Как можно видеть, количество признаков уменьшилось в 10 раз.

bake_train_pca <- prep_train_pca |> 
  bake(new_data = NULL)

bake_train_pca

25.7 Первая модель: регрессия с регуляризацией

Когда мы работаем с текстовыми данными и используем большое число признаков для классификации, важно избегать алгоритмов, которые плохо работают с высоким числом измерений (например, k-NN). Вместо этого лучше использовать более эффективные алгоритмы, такие как линейные модели с регуляризацией.

Для задач классификации применяется логистическая регрессия, которая неплохо справляется с разреженными данными благодаря L1-регуляризации (Lasso) или L2-регуляризации (Ridge). В частности, лассо-регуляризация позволяет обнулять незначимые признаки, исключая их тем самым из модели.

Поскольку в нашем датасете три класса, то мы применим многоклассовую логистическую регрессию.

lasso_spec <- multinom_reg(penalty = tune(), mixture = 1) |> 
  set_mode("classification") |> 
  set_engine("glmnet")
lasso_param <- extract_parameter_set_dials(lasso_spec)
  
lasso_grid <- lasso_param |> 
  grid_regular(levels = 3)

lasso_grid
lasso_wflow <- workflow() |> 
  add_model(lasso_spec) |> 
  add_recipe(tfidf_rec)

lasso_wflow
══ Workflow ════════════════════════════════════════════════════════════════════
Preprocessor: Recipe
Model: multinom_reg()

── Preprocessor ────────────────────────────────────────────────────────────────
9 Recipe Steps

• step_mutate()
• step_mutate()
• step_tokenize()
• step_stopwords()
• step_stem()
• step_tokenfilter()
• step_tfidf()
• step_zv()
• step_normalize()

── Model ───────────────────────────────────────────────────────────────────────
Multinomial Regression Model Specification (classification)

Main Arguments:
  penalty = tune()
  mixture = 1

Computational engine: glmnet 

Здесь придется немного (или много) подождать.

library(tictoc)
library(future)

plan(multisession, workers = 5)

tic()
set.seed(10032025)
lasso_tune <- lasso_wflow |> 
  tune_grid(
    resamples = folds, 
    grid = lasso_grid,
    metrics = metric_set(accuracy, roc_auc),
    control = control_resamples(save_pred = TRUE, save_workflow = TRUE)
  )

lasso_tune 

toc()
# 61.116 sec elapsed
plan(sequential)
autoplot(lasso_tune)

Наша модель достигла не очень высокой точности: она работает лишь немногим лучше нулевой, и хуже всего предсказывает нейтральные отзывы.

collect_predictions(lasso_tune) |> 
  roc_curve(truth = sentiment, .pred_neg:.pred_pos)  |> 
  ggplot(aes(1 - specificity, sensitivity, color = .level)) +
  geom_abline(slope = 1, color = "gray50", lty = 2, alpha = 0.8) +
  geom_path(linewidth = 1.5, alpha = 0.7) +
  labs(color = NULL) +
  coord_fixed() +
  theme_light()

25.8 SVM

svm_spec <- svm_linear(cost = tune()) |> 
  set_mode("classification") |> 
  set_engine("LiblineaR")
svm_param <- extract_parameter_set_dials(svm_spec)

svm_grid <- svm_param |> 
  grid_regular(levels = 3)

svm_grid

25.9 Random forest

rf_spec <- rand_forest(
  trees = tune()) |>        
  set_mode("classification") |> 
  set_engine("ranger")

rf_spec
Random Forest Model Specification (classification)

Main Arguments:
  trees = tune()

Computational engine: ranger 

Для случайного леса создадим решетку вручную.

rf_grid <- tibble(trees = c(500, 1000, 2000))

rf_grid

25.10 Workflow_set

wflow_set <- workflow_set(  
  preproc = list(tfidf = tfidf_rec,
                 pca = pca_rec),  
  models = list(svm = svm_spec,
                rf = rf_spec),  
  cross = TRUE
)


wflow_set
wflow_set_final <- wflow_set |> 
  option_add(grid = svm_grid, id = "tfidf_svm") |> 
  option_add(grid = svm_grid, id = "pca_svm") |> 
  option_add(grid = rf_grid, id = "tfidf_rf") |> 
  option_add(grid = rf_grid, id = "pca_rf")

Снова немного подождем. Обратите внимание: обе модели подгоняются 5 раз с тремя разными гиперпараметрами и двумя рецептами препроцессинга. Это займет время, так как по сути мы обучаем \(2 \times 2 \times 3 \times 5 = 60\) моделей.

plan(multisession, workers = 5)

set.seed(09022025)
tic()
wflow_set_fit <- 
  workflow_map(
    wflow_set_final, 
    verbose = TRUE, 
    metrics = metric_set(accuracy),
    resamples = folds,
    control = control_resamples(save_pred = TRUE),
    fn = "tune_grid"
  )
toc()
# i 1 of 4 tuning:     tfidf_svm
# ✔ 1 of 4 tuning:     tfidf_svm (23.5s)
# i 2 of 4 tuning:     tfidf_rf
# ✔ 2 of 4 tuning:     tfidf_rf (44.7s)
# i 3 of 4 tuning:     pca_svm
# ✔ 3 of 4 tuning:     pca_svm (19.4s)
# i 4 of 4 tuning:     pca_rf
# ✔ 4 of 4 tuning:     pca_rf (35.9s)
# > toc()
# 125.705 sec elapsed
plan(sequential)

25.11 Объединение воркфлоу

wflow_set_final <- wflow_set_fit |> 
  bind_rows(as_workflow_set(lasso_tfidf = lasso_tune))

wflow_set_final

Лучшие результаты стабильно показывает случайный лес.

autoplot(wflow_set_final, metric = "accuracy") + 
  theme_light() +
  theme(legend.position = "none") +
  geom_text(aes(y = (mean - 2*std_err), label = wflow_id), angle = 90, hjust = 1) +
  lims(y = c(-0.1, 1))

25.12 Выбор модели и окончательная настройка

rank_results(wflow_set_final, rank_metric = "accuracy")
autoplot(wflow_set_fit, id = "tfidf_rf") +
  theme_light()

best_results <- 
   wflow_set_final |> 
   extract_workflow_set_result("tfidf_rf") |> 
   select_best(metric = "accuracy")

best_results

Обратите внимание: на этом этапе мы “распечатываем” тестовые данные!

rf_test_results <- 
   wflow_set_final |> 
   extract_workflow("tfidf_rf") |> 
   finalize_workflow(best_results) |> 
   last_fit(split = data_split)

rf_test_results

25.13 Оценка

Оцениваем эффективность на тестовых данных.

collect_metrics(rf_test_results)
rf_test_results |> 
  collect_predictions() |>
  conf_mat(truth = sentiment, estimate = .pred_class) |> 
  autoplot(type = "heatmap") +
  scale_fill_gradient(low = "white", high = "#233857") +
  theme(panel.grid.major = element_line(colour = "#233857"),
        axis.text = element_text(color = "#233857"),
        axis.title = element_text(color = "#233857"),
        plot.title = element_text(color = "#233857"),
        axis.text.x = element_text(angle = 90))

Другой способ может заключаться в том, чтобы снизить размерность за счет эмбеддингов. Об этом пойдет речь в следующем уроке.